home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / thomas / thomas.lha / Thomas / Thomas-1.1 / portable / dynwind.scm next >
Text File  |  1992-09-18  |  2KB  |  54 lines
  1. ; "dynwind.scm", wind-unwind-protect for Scheme
  2. ; Copyright (c) 1992, Aubrey Jaffer
  3.  
  4. ;This facility is a generalization of Common Lisp `unwind-protect',
  5. ;designed to take into account the fact that continuations produced by
  6. ;CALL-WITH-CURRENT-CONTINUATION may be reentered.
  7.  
  8. ;  (dynamic-wind <thunk1> <thunk2> <thunk3>)        procedure
  9.  
  10. ;The arguments <thunk1>, <thunk2>, and <thunk3> must all be procedures
  11. ;of no arguments (thunks).
  12.  
  13. ;DYNAMIC-WIND calls <thunk1>, <thunk2>, and then <thunk3>.  The value
  14. ;returned of <thunk2> is returned as the result of DYNAMIC-WIND.
  15. ;<thunk3> is also called just before <thunk2> calls any continuations
  16. ;created by CALL-WITH-CURRENT-CONTINUATION.  If <thunk2> captures its
  17. ;continuation as an escape procedure, <thunk1> is invoked just before
  18. ;continuing that continuation.
  19.  
  20. (define *winds* '())
  21.  
  22. (define (dynamic-wind <thunk1> <thunk2> <thunk3>)
  23.   (<thunk1>)
  24.   (set! *winds* (cons (cons <thunk1> <thunk3>) *winds*))
  25.   (let ((ans (<thunk2>)))
  26.     (set! *winds* (cdr *winds*))
  27.     (<thunk3>)
  28.     ans))
  29.  
  30. (define call-with-current-continuation
  31.   (let ((oldcc call-with-current-continuation))
  32.     (lambda (proc)
  33.       (let ((winds *winds*))
  34.     (oldcc
  35.      (lambda (cont)
  36.        (proc (lambda (c2)
  37.            (dynamic:do-winds *winds* winds)
  38.            (cont c2)))))))))
  39.  
  40. (define (dynamic:do-winds from to)
  41.   (set! *winds* from)
  42.   (cond ((eq? from to))
  43.     ((null? from)
  44.      (dynamic:do-winds from (cdr to))
  45.      ((caar to)))
  46.     ((null? to)
  47.      ((cdar from))
  48.      (dynamic:do-winds (cdr from) to))
  49.     (else
  50.      ((cdar from))
  51.      (dynamic:do-winds (cdr from) (cdr to))
  52.      ((caar to))))
  53.   (set! *winds* to))
  54.